00100	C  THIS PROGRAM CREATES FUNCTIONS FOR THE MUSIC PROGRAM USING 
00200	C  'SEG' OR 'SYNTH'.  UP TO 10 FUNCTIONS CAN BE STORED IN A
00300	C  SINGLE FILE.  ONCE CREATED, THE FUNCTIONS MAY BE CHANGED
00400	C  AND PUT BACK IN THE SAME FILE OR INTO A NEW ONE.
00500	C  NO MORE THAN 50 INPUTS FOR ONE FUNCTION!
00600	C  TYPE 'C' (= CRUNCH)  FOR SPECIAL FEATURE SUBR.
00615	C  'Z' FOR "CHANGE OR FINISH?" WILL JUMP DIRECTLY TO "CRUNCH" MODE.
00700	C  WITH S(EE), <CR> WILL REPEAT SEE COMMAND WITHOUT ASKING FOR FILE.
00800	C'SP'(FOR "SEE")PLOTS IT (SA=ALL);'SL' PUTS IT OUT ON THE LPT.
00900	C FOR EXPONENTIALS GET INTO 'SEG'.  TYPE 'X', DECAY FAC, N.  IF 
01000	C  N IS NON-ZERO THE FUNCTION WILL NOT! NORMALIZE (IE. NOT GO TO 0).
01100	C  AFTER A FILE HAS BEEN READ IN,
01200	C  <CR> FOR 'TYPE FILE' WILL HOLD ON TO IT.
01300	C  LOAD WITH -- WRIFUN,FUSUB,DFUEXP,SSS
01500		COMMON/S/H,AMP,CON,PH
01600		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
01700		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
01800		COMMON FUNC(512),F2(512),K,I
01900		COMMON/LT/LPTY,JSEE
02000		DIMENSION RF(4)
02200	21	FORMAT(' C=CHANGE, F=FINISH '$)
02300	22	FORMAT(' NEW FUNC, EDIT, CRUNCH, DELETE, RENAME, SEE?   '$)
02400	23	FORMAT(' SEG OR SYNTH?   '$)
02500	24	FORMAT(' TYPE FUNCTION NAME   '$)
02600	25	FORMAT(' TYPE FILE NAME   '$)
02700	26	FORMAT(I3,') TYPE AMPL, STEP#  '$)
02800	C  'X' HERE WILL MAKE EXPON. FUNC.
02900	28	FORMAT(' 0=NORM,OR H,A,P,K   '$)
03000	280	FORMAT(
03100		1' UP TO 10 FUNCTIONS MAY BE STORED IN EACH FILE'/
03200		1' TYPE "B" TO BACKUP AT ANY TIME'//)
03300	30	FORMAT(8F)
03400	31	FORMAT(1XA5,A1,5A5/)
03500	34	FORMAT(A5,'(',A5,');',A5)
03600	35	FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
03700	37	FORMAT(8F9.3)
03800	371	FORMAT(I3,') ',4F8.2)
03900	372	FORMAT(I,21F)
04000	38	FORMAT(2(A5,A1),23A2)
04300	40	FORMAT(11(A1,A3))
04400	41	FORMAT(' ADD TO AN EXISTING FILE?   '$)
04500	42	FORMAT(' WHICH FUNC?   '$)
04600	47	FORMAT(' C=CHNG, I=INSRT, D=DEL -- + LN# & CHNGS '$)
04700	48	FORMAT(' X,N(=DECAY FAC.) FOR XPONTLS')
04800	2281	TYPE 280
04900	281	KZ=0
05000		JSEE=0
05100		LPTY=5
05200	C   USED IN RELATIVE VECTOR ROUTINE
05300		Z=0
05400		EY=0
05500		ICUR=0
05600		XP=0
05650		KT=0
05700		FNUM=0
05800		OLD=0
05900		FNUM1=0
06000		TYPE 22
06100		ACCEPT 40,ON,P
06200	1281	IPLOT=0
06300		IF(ON.EQ.'N'.OR.(ON.EQ.' '.AND.ONX.NE.'S'))GO TO 1000
06400		IF(ON.NE.' ')GO TO 100
06500		ON=ONX
06700	C  RETURNS FOR MORE "SEE"
06800		GO TO 4281
06900	100	ONX=ON
07000		TYPE 25
07100		OLD=-1
07200		ACCEPT 38,FLNM1
07300		IF(FLNM1.EQ.' ')FLNM1=FLNM
07400		IF(FLNM1.EQ.0)GO TO 100
07500		IF(FLNM.NE.FLNM1)GO TO 2151
07600		OLD=0
07700	4281	TYPE 40,B
07800		GO TO 1402
08000	2151	FLNM=FLNM1
08100		CALL READ1
08800	3402	JX=-1
08900		LX=0
08910		IF(P.EQ.'A')GO TO 402
08955	C  "SA" WILL PLOT ALL FUNCS IN FILE
09000		TYPE 40,B
09100		IF(B(1,2).NE.' ')GO TO 1402
09200		FNUM1=B(2,1)
09300	C  ONLY ONE FUNC IN FILE.
09400		GO TO 402
09500	1402	TYPE 42
09600		ACCEPT 40,BU
09700		IF(BU.EQ.'B')GO TO 281
09800		REREAD 38,FNUM1
09900		IDEL=0
10000	C  LX IS MAIN COUNTER
10100		IF(OLD)GO TO 402
10200		DO 1302 JX=1,10
10300	1302	IF(FNUM1.EQ.FN(JX))GO TO 5402
10400		GO TO 3402
10500	2202	CALL DPYF(-1,FUNC)
10600	C  -1 SUPRESSES DISPLAY
10700		IF(P.EQ.'P'.OR.P.EQ.'A'.OR.P.EQ.0)GO TO 70
10800		LPTY=3
10900		JSEE=-1
11000		CALL DPY(FUNC,1)
11100		CALL EXIT
11200	70	CALL PLOTIT(FUNC,XA(JX),P)
11210		IF(P.EQ.'P')GO TO 2281
11220		JX=JX+1
11230		IF(B(2,JX).NE.' '.AND.JX.LE.10)GO TO 2202
11300	CC	P=0
11400		GO TO 2281
11500	402	CALL READER
11600	C  AT THIS POINT LX=TOTAL FUNCS+1
11620	5402	IF(P.EQ.'A')JX=1
11700	1202	IF(ON.NE.'C'.AND.ON.NE.'S'.AND.ON.NE.'D')GO TO 3281
11800		IF(P.EQ.'P'.OR.P.EQ.'L'.OR.P.EQ.'A')GO TO 2202
11900		CALL DPYF(JX,FUNC)
12000		IF(ON.EQ.'S')GO TO 2281
12100		IF(ON.EQ.'C')GO TO 1201
12200		TYPE 1139
12300		ACCEPT 40,IDEL
12400		IF(IDEL.EQ.'N')GO TO 2281
12500		IDEL=JX
12600		LX=LX-1
12700	C  NOW LX=TOTAL # OF FUNCS.
12800		CALL WRIFUN
12900	1139	FORMAT(' DELETE IT? ',$)
13000	3281	X=' '
13100		TYPE 31,XA(JX),X,FN(JX)
13200		JT=4
13300		IF(XA(JX).EQ.'SEG')JT=2
13400		KZ=1
13500		DO 137	K=1,50
13600		KZ=KZ+1
13700		DO 138 L=1,JT
13800	138	A(K,L)=AA(L,K,JX)
13900	137	IF(A(K,1).EQ.999.OR.A(K,2).GE.100)GO TO 4401
14000	
14100	4401	Z=-1
14200		IF(A(K,2).LE.100)GO TO 4403
14300		IF(K.GT.1)GO TO 4404
14400		CALL DPYF(JX,FUNC)
14500		IF(ON.EQ.'R')GO TO 3032
14600		TYPE 4405
14700		A(1,2)=520
14950		GO TO 4201
15000	4404	TYPE 4402
15100	4403	IF(JT.EQ.2)EY='EG'
15200		GO TO 1032
15300	4402	FORMAT('  IT WAS SMOOTHED.')
15400	4405	FORMAT(' CANNOT EDIT CRUNCHED FUNCS.'/)
15500	1000	TYPE 23
15600		ACCEPT 40,BU
15700		IF(BU.EQ.'B')GO TO 281
15800		REREAD 40,X,EY
15900	1032	CALL ZERO(FUNC)
16000	C  CLEARS THE FUNC.
16100		ISMOO=0
16200		IF(EY.EQ.'EG')GO TO 800
16300	151	EY=0
16400		JT=4
16500	C  FOR WRIFUN
16600	15	KT=1
16700	104	IF(Z.EQ.-1.OR.KT.LT.KZ)GO TO 102
16800		IF(Z.EQ.1)GO TO 2032
16900	1041	KZ=0
17000		TYPE 28
17100		ACCEPT 40,BU
17200		IF(BU.EQ.'B')GO TO 509
17300		REREAD 30,(A(KT,K),K=1,4)
17400	C ACCEPT HARM,AMPL,PHASE,KONSTANT(IF K>100, MULTIPLIES WAVE *(K-100))
17500	102	H=A(KT,1)
17600		IF(H.EQ.0.OR.H.EQ.999.)GO TO 2200
17700	C   999 ENDS 'READIN' SYNTHS
17800		IF(Z.GT.0)TYPE 371,KT,(A(KT,K),K=1,4)
17900		AMP=A(KT,2)
18000		PH=A(KT,3)
18100		CON=A(KT,4)
18200		CALL SYN(FUNC)
18300		KT=KT+1
18400		IF(KZ.LE.KT)CALL DPY(FUNC,1)
18500		GO TO 104
18510	2201	IF(JT.NE.2.OR.A(KT-1,2).GT.100)GO TO 1201
18545		CALL STORE(10)
18580		XA(10)='SEG'
18590		CALL DPYF(10,FUNC)
18700	1201	CALL ZFUNC
18800	C  THIS WILL BE FOR SPECIAL FEATURE PACKAGE
18810		IF(KT.EQ.512)GO TO 2281
18855	C  FOR BACKUP
18860	4201	EY='EG'
18900		KT=2
19000		GO TO 900
19100	2200	CALL NORM(FUNC)
19200	C   NORMALIZES THE FUNCTION
19300	201	IF(BU.EQ.'C')GO TO 2032
19400		IF(ON.EQ.'R')GO TO 3032
19500	204	CALL DPY(FUNC,1)
19600	2011	TYPE 21
19700		IF(EY.EQ.'EG')TYPE 271
19800	C   CHANGE IT?
19900		ACCEPT 40,BU
20000		IF(BU.EQ.'C')GO TO 210
20300		IF(BU.EQ.'F')GO TO 900
20400		IF(BU.EQ.'S')GO TO 7000
20500		IF(BU.EQ.'Z')GO TO 2201
20510	C  TO USE CURRENT FUNC IN CRUNCH
20600		IF(BU.NE.'B')GO TO 2032
20700		IF(EY.EQ.'EG')GO TO 509
20800		GO TO 5091
20900	C   NEXT IS FOR CHANGES ('C' OR <CR>)
21300	2032	TYPE 47
21400		ACCEPT 40,K
21500		REREAD 372,L,X,RF
21600		IF(X.NE.0.OR.RF(1).NE.0)GO TO 211
21700		IF(EY.EQ.'EG')GO TO 204
21800		BU=0
21900		GO TO 1041
22000	211	L=X
22100		IF(K.EQ.'I')GO TO 212
22200		IF(K.NE.'D')GO TO 205
22300	C   JUMP IF NO DELETE
22400		KT=KT-1
22500		DO 209 K=L,KT
22600		DO 209 J=1,4
22700	209	A(K,J)=A(K+1,J)
22800		GO TO 210
22900	205	X=RF(2)
23000		IF(EY.NE.'EG')GO TO 1207
23100		IF(X.GE.A(L+1,2).AND.L.LT.KT-1)GO TO 2032
23200		GO TO 208
23300	212	IF(RF(2).NE.0)GO TO 213
23400		RF(2)=RF(1)
23500		RF(1)=X
23600		L=KT
23700	213	IF(EY.NE.'EG')GO TO 214
23800		X=RF(2)
23900		DO 215 K=1,KT
24000		Y=A(K,2)
24100		IF(X.GT.Y)GO TO 215
24200	C   JUMP IF NOT PAST STEP NUM.
24300		L=K
24400		IF(X.EQ.Y)GO TO 208
24500	C   IF STEP=ANOTHER STEP, IT WORKS LIKE 'C'HANGE.
24600		GO TO 214
24700	215	CONTINUE
24800	214	KT=KT+1
24900		DO 206 K=KT,L,-1
25000		DO 206 J=1,4
25100	206	A(K,J)=A(K-1,J)
25200		GO TO 207
25300	C   TO TYPE OLD NUMBERS
25400	208	IF(X.LE.A(L-1,2).AND.L.GT.1)GO TO 2032
25500	1207	TYPE 371,L,(A(L,K),K=1,4)
25600	207	DO 202 K=1,4
25700	202	A(L,K)=RF(K)
25800	210	KZ=KT
25900		Z=1
26000		GO TO 1032
26100	271	FORMAT('+S=SMOOTH  '$)
26110	C  FOR RENAMES
26140	3032	Z=-1
26170		GO TO 901
26200	900	TYPE 41
26300	C  ADD TO EXISTING FILE
26400		ISKP=0
26500		ACCEPT 40,Z
26600	9000	IF(Z.EQ.'B')GO TO 204
26650		IF(Z.EQ.' ')GO TO 900
26700		TYPE 25
26800		ACCEPT 38,FLNM
26810		IF(FLNM.EQ.'B')GO TO 204
26900		IF(FLNM.EQ.' ')FLNM=FLNM1
27100	901	JT=4
27200		IF(EY.EQ.'EG')JT=2
27300		CALL WRIFUN
27400		GO TO 900
27500	C  COMES BACK IF NO ROOM IN FILE FOR NEW FUNC.
27600	
27700	161	DO 261 K=1,512
27800	261	FUNC(K)=EXP((1-K)/STEP)
27900		KT=2
28000		XP=-1
28100		IF(H.NE.0)GO TO 7009
28200	C  H≠0 = NO NORMALIZATION OF XPONTL
28300		X=FUNC(512)
28400		DO 361 K=1,512
28500	361	FUNC(K)=FUNC(K)-(K-1)/511.*X
28600		GO TO 7009
28700	800	IF(XP)GO TO 510
28800		X=0
28900		IK=0
29000		JT=2
29100	C  JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
29200		Y=0
29300		KT=1
29400	504	IF(KT.GE.KZ)GO TO 510
29500		AMP=A(KT,1)
29600	5008	STEP=A(KT,2)
29700		IF(STEP.LE.A(KT-1,2).AND.KT.GT.1)GO TO 509
29800	C   SO IT CAN'T GO BACKWARDS
29900		GO TO 5071
30000	611	FORMAT(' NO MORE THAN 50 SEGS'/)
30100	610	TYPE 611
30200	509	KT=KT-1
30300	5091	IF(KT.LT.1)GO TO 281
30400		GO TO 210
30500	510	IF(KT.EQ.1)TYPE 48
30600		TYPE 26,KT
30700		KZ=0
30800		ACCEPT 40,BU
30900		IF(BU.EQ.'B')GO TO 509
31000	61	REREAD 30,AMP,STEP,H
31100		IF(STEP.LT.1)STEP=1
31200		IF(BU.EQ.'X')GO TO 161
31300	C  TYPE 'X' FOR EXPON. FUNC. + DECAY FACTOR, +1 = NO NORM.
31400	C  WE START WITH STEP 1 (NOT 0)
31500	5071	IF(KT.GT.50)GO TO 610
31600	C   TOO MANY SEGS
31700		IF(Z.GT.0)TYPE 371,KT,AMP,STEP
31800		IF(STEP.GT.100)STEP=100
31900		STPS=STEP-X
32000		IF(STPS.LE.0.AND.KT.NE.1)GO TO 504
32100	C   SO IT CAN'T BACKUP HERE
32200		IS=STPS
32300		IF(STEP.LE.1.)Y=AMP
32400		DIF=(AMP-Y)/STPS
32500		IJ=STPS*5.12
32600	CC	IK=X*5.12
32700		DO 2031 K=1,IJ
32800	2031	FUNC(K+IK)=Y+DIF*K/5.12
32900	C   100 STEPS ARE CONVERTED HERE TO 512
33000		IK=IK+IJ
33100	12	Y=AMP
33200		X=STEP
33300		A(KT,1)=Y
33400		A(KT,2)=X
33500	7001	KT=KT+1
33600	C   KT COUNTS SEGMENTS
33700		IF(STEP.LT.100)GO TO 504
33800		GO TO 201
33900	
34000	
34100	7000	IF(ISMOO)GO TO 201
34200		IF(KT.LE.20)GO TO 7007
34300		TYPE 7008
34400		GO TO 509
34500	7008	FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
34600	7007	CALL SSS(A,KT-1,FUNC)
34700	C   DRAWS GRID 2
34800	7009	A(KT-1,2)=520
34900		ISMOO=-1
35000	C  SO YOU CAN'T COME BACK 2 TIMES
35100		GO TO 201
35200		END